home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TTT51SRC / FASTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-08  |  13KB  |  456 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.10                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {               Copyright 1986-1993 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}
  13.                      {       Unit:  FastTTT5          }
  14.                      {--------------------------------}
  15.  
  16. { Update History:  4/01/89 5.00a    Changed VertLine and Horizline
  17.                            5.01a    Added DEBUG compiler directive
  18.                    2/20/90 5.02a    Changed Vertline again!
  19.                   01/04/93 5.10   DPMI compatible version
  20. }
  21.  
  22. {$S-,R-,V-}
  23. {$IFNDEF DEBUG}
  24. {$D-}
  25. {$ENDIF}
  26.  
  27. unit FastTTT5;
  28.  
  29. interface
  30.  
  31. Uses DOS, CRT;
  32.  
  33. const
  34.     MaxScreenStr = 80;
  35.     FCol:byte = white;
  36.     BCol:byte = black;
  37. type
  38.   StrScreen = string[MaxScreenStr];
  39. var
  40.   BaseOfScreen: pointer;       {Base address of video memory}
  41.   ActiveScreenPtr: pointer;    {address of virtual screen}
  42.   SnowProne : Boolean;         {Check for snow on color cards?}
  43.   Speed : longint;             {delay factor for growbox routine}
  44.   ColorScreen: boolean;
  45.  
  46. Function  Attr(F,B:byte):byte;
  47. Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen);
  48. Procedure PlainWrite(Col,Row:byte; St:StrScreen);
  49. Procedure ColWrite(Col,Row:byte; St:StrScreen);
  50. Procedure FWrite(St:StrScreen);
  51. Procedure FWriteLN(St:StrScreen);
  52. Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  53. Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  54. Function  Replicate(N:byte; Character:char):StrScreen;
  55. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  56. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  57. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  58. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  59. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  60. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  61. Procedure ClearLine(Y,F,B:integer);
  62. Procedure WriteAT(X,Y,F,B:integer; St:StrScreen);
  63. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:StrScreen);
  64. Procedure WriteCenter(LineNO,F,B:integer; St:StrScreen);
  65. Procedure WriteVert(X,Y,F,B:integer; St:StrScreen);
  66. Function  EGAVGASystem: boolean;
  67. Procedure InitFastTTT;
  68.  
  69. implementation
  70.  
  71. {$L FASTTTT5}
  72. {$IFOPT F-}
  73.    {$DEFINE FOFF}
  74.    {$F+}
  75. {$ENDIF}
  76.   procedure AsmWrite(var scrptr; Wid,Col,Row,Attr:byte; St:String); external;
  77.   procedure AsmPWrite(var scrptr; Wid,Col,Row:byte; St:String); external;
  78.   procedure AsmAttr(var scrptr; Wid,Col,Row,Attr,Len:byte); external;
  79. {$IFDEF FOFF}
  80.    {$F-}
  81.    {$UNDEF FOFF}
  82. {$ENDIF}
  83.  
  84. procedure FastWrite(Col,Row,Attr:byte; St:StrScreen);
  85. {}
  86. begin
  87.    AsmWrite(ActiveScreenPtr^,80,Col,Row,Attr,St);
  88. end; {FastWrite}
  89.  
  90. procedure PlainWrite(Col,Row:byte; St:StrScreen);
  91. {}
  92. begin
  93.    AsmPWrite(ActiveScreenPtr^,80,Col,Row,St);
  94. end; {PlainWrite}
  95.  
  96. procedure Attribute(Col,Row,Attr:byte; Number:Word);
  97. {}
  98. begin
  99.    AsmAttr(ActiveScreenPtr^,80,Col,Row,Attr,Number);
  100. end; {Attribute}
  101.  
  102.   Function Attr(F,B:byte):byte;
  103.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  104.   begin
  105.       Attr := (B Shl 4) or F;
  106.   end;  {Func Attr}
  107.  
  108.   Procedure ColWrite(Col,Row:byte; St:StrScreen);
  109.   begin
  110.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  111.   end;
  112.  
  113.   Procedure FWrite(St:StrScreen);
  114.   var Col,Row : byte;
  115.   begin
  116.       Col := WhereX;
  117.       Row := WhereY;
  118.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  119.       GotoXY(Col+length(St),Row);
  120.   end;
  121.  
  122.   Procedure FWriteLN(St:StrScreen);
  123.   var Col,Row : byte;
  124.   begin
  125.       Col := WhereX;
  126.       Row := WhereY;
  127.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  128.       GotoXY(1,succ(Row));
  129.   end;
  130.  
  131.   
  132.  
  133.   Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  134.   {changes color attrib at specified coords}
  135.   var
  136.     I,X,A : byte;
  137.   begin
  138.       A := Attr(F,B);
  139.       X := Succ(X2-X1);
  140.       For I := Y1 to Y2 do
  141.           Attribute(X1,I,A,X);
  142.   end; {Proc Attrib}
  143.  
  144.  
  145.   Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  146.   {writes text to the screen with a click!}
  147.   var
  148.     I : Integer;
  149.     L,A : byte;
  150.   begin
  151.       A := attr(F,B);
  152.       L := length(St);
  153.       For I := L downto 1 do
  154.       begin
  155.           Fastwrite(Col,Row,A,copy(St,I,succ(L-I)));
  156.           sound(500);delay(20);nosound;delay(30);
  157.       end;
  158.   end;
  159.  
  160.   Function Replicate(N : byte; Character:char):StrScreen;
  161.   {returns a string with Character repeated N times}
  162.   var tempstr : StrScreen;
  163.   begin
  164.       If N = 0 then
  165.          TempStr := ''
  166.       else
  167.       begin
  168.          If (N > 80) then
  169.             N := 1;
  170.          fillchar(tempstr,N+1,Character);
  171.          Tempstr[0] := chr(N);
  172.       end;
  173.       Replicate := Tempstr;
  174.   end;
  175.  
  176.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  177.   var
  178.     Y : integer;
  179.     attrib : byte;
  180.   begin
  181.       If x2 > 80 then x2 := 80;
  182.       Attrib := attr(F,B);
  183.       For Y := y1 to y2 do
  184.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  185.   end;   {cleartext}
  186.  
  187.   Procedure ClearLine(Y,F,B:integer);
  188.   begin
  189.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  190.   end;
  191.  
  192.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  193.   {Draws a box on the screen}
  194.   var
  195.     I:integer;
  196.     corner1,corner2,corner3,corner4,
  197.     horizline,
  198.     vertline : char;
  199.     attrib : byte;
  200.   begin
  201.       case boxtype of
  202.       0:begin
  203.             corner1:=' ';
  204.             corner2:=' ';
  205.             corner3:=' ';
  206.             corner4:=' ';
  207.             horizline:=' ';
  208.             vertline:=' ';
  209.         end;
  210.       1:begin
  211.             corner1:='┌';
  212.             corner2:='┐';
  213.             corner3:='└';
  214.             corner4:='┘';
  215.             horizline:='─';
  216.             vertline:='│';
  217.         end;
  218.       2:begin
  219.             corner1:='╔';
  220.             corner2:='╗';
  221.             corner3:='╚';
  222.             corner4:='╝';
  223.             horizline:='═';
  224.             vertline:='║';
  225.         end;
  226.       3:begin
  227.             corner1:='╓';
  228.             corner2:='╖';
  229.             corner3:='╙';
  230.             corner4:='╜';
  231.             horizline:='─';
  232.             vertline:='║';
  233.         end;
  234.       4:begin
  235.             corner1:='╒';
  236.             corner2:='╕';
  237.             corner3:='╘';
  238.             corner4:='╛';
  239.             horizline:='═';
  240.             vertline:='│';
  241.         end;
  242.     else
  243.        corner1:=chr(ord(Boxtype));
  244.        corner2:=chr(ord(Boxtype));
  245.        corner3:=chr(ord(Boxtype));
  246.        corner4:=chr(ord(Boxtype));
  247.        horizline:=chr(ord(Boxtype));
  248.        vertline:=chr(ord(Boxtype));
  249.     end;{case}
  250.     attrib := attr(F,B);
  251.     FastWrite(X1,Y1,attrib,corner1);
  252.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  253.     FastWrite(X2,Y1,attrib,corner2);
  254.     For I := Y1+1 to Y2-1 do
  255.     begin
  256.         FastWrite(X1,I,attrib,vertline);
  257.         FastWrite(X2,I,attrib,vertline);
  258.     end;
  259.     FastWrite(X1,Y2,attrib,corner3);
  260.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  261.     FastWrite(X2,Y2,attrib,corner4);
  262.   end; {Proc Box}
  263.  
  264.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  265.   {Draws a box and clears text within Box frame}
  266.   begin
  267.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  268.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  269.   end;
  270.  
  271.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  272.   {Draws exploding filled box!}
  273.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  274.   begin
  275.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  276.          Ratio :=   2
  277.       else
  278.          Ratio :=  1;
  279.       TX2 := (X2 - X1) div 2 + X1 + 2;
  280.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  281.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  282.       TY1 := TY2 - 3;
  283.       If (X2-X1) < 3 then
  284.       begin
  285.          TX2 := X2;
  286.          TX1 := X1;
  287.       end;
  288.       If (Y2-Y1) < 3 then
  289.       begin
  290.          TY2 := Y2;
  291.          TY1 := Y1;
  292.       end;
  293.       repeat
  294.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  295.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  296.            If TY1 > Y1  then TY1 := TY1 - 1;
  297.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  298.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  299.            For I := 1 to Speed*1000 do {nothing};
  300.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  301.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  302.   end;
  303.  
  304.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  305.   var
  306.     I : integer;
  307.     Horizline : char;
  308.     attrib : byte;
  309.   begin
  310.       case LineType of                     {5.00a}
  311.       0       : HorizLine := ' ';
  312.       2,4,7,9 : Horizline := '═';
  313.       1,3,6,8 : HorizLine := '─';
  314.       else HorizLine := Chr(LineType);
  315.       end; {case}
  316.       Attrib := attr(F,B);
  317.       If X2 > X1 then
  318.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  319.       else
  320.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  321.   end;   {horizline}
  322.  
  323.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  324.   var
  325.     I : integer;
  326.     vertline : char;
  327.     attrib : byte;
  328.   begin
  329.       case LineType of                {5.00a}
  330.       0       : VertLine := ' ';
  331.       2,3,7,9 : Vertline := '║';      {5.02a}
  332.       1,4,6,8 : VertLine := '│';      {5.02a}
  333.       else VertLine := Chr(LineType);
  334.       end; {case}
  335.       Attrib := attr(F,B);
  336.       If Y2 > Y1 then
  337.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  338.       else
  339.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  340.   end;   {vertline}
  341.  
  342.   Procedure WriteAT(X,Y,F,B:integer;St:StrScreen);
  343.   begin
  344.       Fastwrite(X,Y,attr(F,B),St);
  345.   end;
  346.  
  347.   Procedure WriteCenter(LineNO,F,B:integer;St:StrScreen);
  348.   begin
  349.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  350.   end;
  351.  
  352.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:StrScreen);
  353.   var X : integer;
  354.   begin
  355.       If length(St) >= X2 - X1 + 1 then
  356.          WriteAT(X1,Y,F,B,St)
  357.       else
  358.       begin
  359.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  360.           WriteAT(X,Y,F,B,St);
  361.       end;
  362.   end;
  363.  
  364.   Procedure WriteVert(X,Y,F,B:integer;ST : StrScreen);
  365.   var
  366.     I:integer;
  367.     Tempstr:StrScreen;
  368.   begin
  369.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  370.       For I := 1 to length(St) do
  371.       begin
  372.           Tempstr := st[I];
  373.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  374.       end;
  375.   end;
  376.  
  377.   Function EGAVGASystem: boolean;
  378.   {}
  379.   var  Regs : registers;
  380.   begin
  381.       with Regs do
  382.       begin
  383.           Ax := $1C00;
  384.           Cx := 7;
  385.           Intr($10,Regs);
  386.           If Al = $1C then  {VGA}
  387.           begin
  388.               EGAVGASystem := true;
  389.               exit;
  390.           end;
  391.           Ax := $1200;
  392.           Bl := $32;
  393.           Intr($10,Regs);
  394.           If Al = $12 then {MCGA}
  395.           begin
  396.               EGAVGASystem := true;
  397.               exit;
  398.           end;
  399.           Ah := $12;
  400.           Bl := $10;
  401.           Cx := $FFFF;
  402.           Intr($10,Regs);
  403.           EGAVGASystem := (Cx <> $FFFF);  {EGA}
  404.      end; {with}
  405.   end; {of func NoSnowSystem}
  406.  
  407.   Function Get_Video_Mode:byte;
  408.   {}
  409.   var
  410.      Regs : registers;
  411.   begin
  412.       with Regs do
  413.       begin
  414.           Ax := $0F00;
  415.           Intr($10,Regs);
  416.           Get_Video_Mode := Al;
  417.       end; {with}
  418.   end; {of proc Video_Mode}
  419.  
  420.   Procedure InitFastTTT;
  421.   begin
  422. {$IFDEF DPMI}
  423.       if Get_Video_Mode = 7 then
  424.       begin
  425.          BaseOfScreen := ptr(segB000,$0000);  {Mono}
  426.          SnowProne := false;
  427.          ColorScreen := false;
  428.       end
  429.       else
  430.       begin
  431.          BaseOfScreen := ptr(segB800,$0000); {Color}
  432.          SnowProne := not EGAVGASystem;
  433.          ColorScreen := true;
  434.       end;
  435. {$ELSE}
  436.       if Get_Video_Mode = 7 then
  437.       begin
  438.          BaseOfScreen := ptr($B000,$0000);  {Mono}
  439.          SnowProne := false;
  440.          ColorScreen := false;
  441.       end
  442.       else
  443.       begin
  444.          BaseOfScreen := ptr($B800,$0000); {Color}
  445.          SnowProne := not EGAVGASystem;
  446.          ColorScreen := true;
  447.       end;
  448. {$ENDIF}
  449.       ActiveScreenPtr := BaseOfScreen;
  450.   end;
  451.  
  452. begin   {the following is always called when the unit is loaded}
  453.     InitFastTTT;
  454.     Speed := 200;
  455. end.
  456.